;(in-package 'user)

;;----------------------------------------------------------------------
;; Last Update:  1-Nov-96 by EHN
;;
;; Language Technologies Institute
;; 11-712 -- Self-Paced Laboratory
;; Algorithms for NLP
;;
;; Module 2: GLR Parsing -- Given Code
;;
;; Copyright (c) 1996, Carnegie Mellon University, All Rights Reserved.

; (defvar *module-home* "/home/ehn/private/glr")
;(defvar *module-home* "/afs/cs/project/cmt-55/lti/Lab/Modules/NLP-712/glr")
(defvar *module-home* "F:/class/NLPLab/workspace/nlp-lab/glr")

;;----------------------------------------------------------------------
;; SET GCL PARAMETERS
;;
;; This is necessary in GCL for the compiler to produce safe
;; code; the default settings don't always produce good binaries.

#+gcl(format t "Setting compiler optimizations for GCL.")
#+gcl(proclaim '(optimize (speed 3) (safety 3) (space 0) (compilation-speed 0)))

;; ----------------------------------------------------------------------
;; LOAD TOMITA PARSER

(defvar *module-dir*)

(setq *module-dir*
      (format nil "~a/tomita-parser" *module-home*))

(defun module-file (file)
  (format nil "~a/~a" *module-dir* file))

;;(load (module-file "v8-4-rt.lisp"))

(load (module-file "v8-4-cl.lisp"))
(load (module-file "ambig-patch.lisp"))
(load (module-file "pns.lisp"))

(setq *module-dir* *module-home*)

;;----------------------------------------------------------------------
;; SET UP TOMITA PARSER

(defvar *max-ambiguity-display*)

(setq *max-ambiguity-display* 0)

;(defvar *out*)

;(setq *out* (open "/dev/null" :direction :output :if-exists :append))

;;----------------------------------------------------------------------
;; PARSER
;;
;; Parser top-level macro call. Don't quote the arguments, e.g.,
;; 
;; > (parser the man sees the boys with the telescope)

(defmacro parser (&rest words)
  `(progn (parse-list ',(append words '($)))
	  (dolist (fs *parse-value*)
	    (pns fs)(terpri))))

;;----------------------------------------------------------------------
;; SYNTACTIC LEXICON

(defvar *synlex*)

(setq *synlex*
      (make-hash-table :size 100 :test #'equal))

(defun make-entry (form)
  (if (stringp (first form))
      (cons `(root ,(first form)) (rest form))
    form))

(defun load-lexicon (file)
  (let (form old)
    (clrhash *synlex*)
    (with-open-file (in file :direction :input)
      (loop
       (setq form (read in nil in))
       (when (eq form in)
         (return))
       (format t "~%SYNLEX: ~s" form)
       (setq old (gethash (first form) *synlex*))
       (if old
           (setf (gethash (first form) *synlex*)
                 (append old (list (make-entry form))))
           (setf (gethash (first form) *synlex*)
                 (list (make-entry form))))))))

(load-lexicon (module-file "glr-lexicon.lisp"))

;;----------------------------------------------------------------------
;; SEMANTIC LEXICON

(defvar *semlex*)

(setq *semlex*
      (make-hash-table :size 100 :test #'equal))

(defun load-semantics (file)
  (let (form old)
    (clrhash *semlex*)
    (with-open-file (in file :direction :input)
      (loop
       (setq form (read in nil in))
       (when (eq form in)
	     (return))
       (format t "~%SEMLEX: ~s" form)
       (setq old (gethash (first form) *semlex*))
       (if old
	   (warn "Duplicate definition for ~s ignored!"
		 (first form))
	 (setf (gethash (first form) *semlex*)
	       form))))))

(load-semantics (module-file "glr-semantics.lisp"))

;;----------------------------------------------------------------------
;; PP ATTACHMENT LICENSING
;; 
;; This variable controls whether or not to always attach PPs (non-NIL)
;; or license the attachments via LICENSE-ATTACHMENT (NIL). Defaults to
;; explicit licensing.

(defvar *always-attach-pp*)

(setq *always-attach-pp* nil)

;;----------------------------------------------------------------------
;; SEMROLE-FILLER-MATCH
;;
;; Performs 4 specific tests, one of which must succeed for the match
;; to be true:
;;
;;  1) Direct match. The PP obj SEM is a member of the role contents
;;     for the head frame.
;;
;;  2) Inheritance on the PP obj. The IS-A  parent of the PP obj SEM
;;     is a member of the role contents for the head frame.
;; 
;;  3) Inheritance on the head. The PP obj SEM is a member of the role
;;     contents for the IS-A parent of the head frame.
;;
;;  4) Inheritance on the head and filler. The IS-A parent of the PP obj
;;     SEM is a member of the role contents for the IS-A parent of the
;;     head frame.

(defun semrole-filler-match (head-frame role filler-frame)
  (let* ((slot (assoc role (rest head-frame)))
	 (head-filler (second slot))
	 (filler-is-a (second (assoc '=is-a (rest filler-frame))))
	 (head-is-a (second (assoc '=is-a (rest head-frame))))
	 (inherited-filler (second (assoc role (rest (lookup-semantics head-is-a)))))
	 )
    (print slot)
    (print head-filler)
    (print filler-is-a)
    (print head-is-a)
    (print inherited-filler)

    (if (and (or head-filler inherited-filler)
	     (or
	      ;; Direct match
	      (eq (first filler-frame)
		  head-filler)
	      ;; Look for parent of filler
	      (eq filler-is-a
		  head-filler)
	      ;; Look in fillers of head parent
	      (eq (first filler-frame)
		  inherited-filler)
	      ;; Look for head parent in inherited fillers
	      (eq filler-is-a
		  inherited-filler)))
	t
      nil)))

;;----------------------------------------------------------------------
;; COMPILE THE GRAMMAR.

#+gcl(system:chdir *module-dir*)
#+lucid(setf (working-directory) *module-dir*)

;(loadgra "given")
(loadgra "glr-grammar")

;;----------------------------------------------------------------------
;; Load the Test Code.

(load "test-code.lisp")


;;----------------------------------------------------------------------
